home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d18 / lzhtv10.arc / CINPUT.PAS next >
Pascal/Delphi Source File  |  1989-04-21  |  12KB  |  502 lines

  1.  
  2. (*
  3.  * Copyright 1987, 1989 Samuel H. Smith;  All rights reserved
  4.  *
  5.  * This is a component of the ProDoor System.
  6.  * Do not distribute modified versions without my permission.
  7.  * Do not remove or alter this notice or any other copyright notice.
  8.  * If you use this in your own program you must distribute source code.
  9.  * Do not use any of this in a commercial product.
  10.  *
  11.  *)
  12.  
  13. {$i prodef.inc}
  14. {$D+}    {Global debug information}
  15. {$L+}    {Local debug information}
  16.  
  17. unit CInput;
  18.  
  19. interface
  20.  
  21.    Uses
  22.       Dos, MiniCrt, Mdosio, Tools;
  23.  
  24.    var
  25.       linenum:       integer;
  26.       pending_keys:  string;
  27.       cmdline:       string;
  28.       par:           string;
  29.       ontime:        integer;
  30.       tleft:         integer;
  31.  
  32.    const
  33.       tlimit:  integer = 10;  {default time limit}
  34.       comport: integer = 0;   {default to local, monitor carrier if 1 or 2}
  35.  
  36.       allow_flagging = false;
  37.       graphics = false;
  38.       red = '';
  39.       green = '';
  40.       yellow = '';
  41.       blue = '';
  42.       magenta = '';
  43.       cyan = '';
  44.       white = '';
  45.       gray = '';
  46.       fun_arcview = 'V';
  47.       fun_textview = 'T';
  48.       fun_xtract = 'X';
  49.       enter_eq = '(Enter)=';
  50.       option = '';
  51.       expert = true;
  52.       dump_user: boolean = false;
  53.  
  54.    type
  55.       user_rec = record
  56.            pagelen: integer;
  57.       end;
  58.  
  59.    const
  60.       user: user_rec = (pagelen:22);
  61.       o_logoff = 'x';
  62.       o_offok = 'x';
  63.       o_offerr = 'x';
  64.  
  65.    const
  66.       queue_size       =  300;   {fixed size of all queues}
  67.       queue_high_water =  255;   {maximum queue.count before blocking}
  68.       queue_low_water  =  100;   {unblock queue at this point}
  69.  
  70.    type
  71.       queue_rec = record
  72.          next_in:  integer;
  73.          next_out: integer;
  74.          count:    integer;
  75.          data:     array[1..queue_size] of char;
  76.       end;
  77.  
  78.    {$i intrcomm.int}
  79.  
  80.    procedure opencom(cport: integer);
  81.    procedure closecom;
  82.    function local: boolean;
  83.  
  84.    procedure disp(msg:  string);
  85.    procedure newline;
  86.    procedure displn(msg:  string);
  87.    procedure space;
  88.    procedure spaces(n: integer);
  89.    procedure input(var line:  string; maxlen:    integer);
  90.    procedure prompt_def(what,options: string);
  91.    procedure get_def(what,options: string);
  92.    procedure get_cmdline_raw(len: integer);
  93.  
  94.    procedure dRED(m: string);
  95.    procedure dGREEN(m: string);
  96.    procedure dYELLOW(m: string);
  97.    procedure dBLUE(m: string);
  98.    procedure dMAGENTA(m: string);
  99.    procedure dCYAN(m: string);
  100.    procedure dWHITE(m: string);
  101.    procedure dGRAY(m: string);
  102.    procedure default_color;
  103.  
  104.    procedure get_cmdline;
  105.    function scan_nextpar(var cmdline: string): string;
  106.    procedure get_nextpar;
  107.  
  108.    function verify_level(fun: char): boolean;
  109.    procedure set_function(fun: char);
  110.    procedure erase_prompt(len: integer);
  111.    procedure check_time_left;
  112.    procedure display_time(left: boolean);
  113.    procedure flag_files;
  114.    procedure make_log_entry(s:string; f:boolean);
  115.    function nomore: boolean;
  116.  
  117.  
  118. (* ------------------------------------------------------------ *)
  119. implementation
  120.  
  121.    {$i intrcomm.inc}
  122.  
  123.    function local: boolean;
  124.    begin
  125.       local := (comport = 0);
  126.    end;
  127.  
  128.    procedure opencom(cport: integer);
  129.    begin
  130.       comport := cport;
  131.       if (comport = 1) or (comport = 2) then
  132.       begin
  133.          INTR_init_com(comport-1);
  134.  
  135.          if (port[port_base+MSR] and MSR_RLSD)=0 then
  136.          begin
  137.             closecom;
  138.             comport := 0;
  139.             displn('[Local Mode]');
  140.          end;
  141.       end;
  142.    end;
  143.  
  144.    procedure closecom;
  145.    begin
  146.       if not local then
  147.          INTR_uninit_com;
  148.    end;
  149.  
  150.    procedure dRED(m: string);    begin disp(RED+m); end;
  151.    procedure dGREEN(m: string);  begin disp(GREEN+m); end;
  152.    procedure dYELLOW(m: string); begin disp(YELLOW+m); end;
  153.    procedure dBLUE(m: string);   begin disp(BLUE+m); end;
  154.    procedure dMAGENTA(m: string);begin disp(MAGENTA+m); end;
  155.    procedure dCYAN(m: string);   begin disp(CYAN+m); end;
  156.    procedure dWHITE(m: string);  begin disp(WHITE+m); end;
  157.    procedure dGRAY(m: string);   begin disp(GRAY+m); end;
  158.    procedure default_color;      begin disp(GRAY); end;
  159.  
  160.  
  161.    (* ------------------------------------------------------------ *)
  162.    procedure get_cmdline;
  163.       (* read next command line *)
  164.    var
  165.       i: integer;
  166.  
  167.    begin
  168.       fillchar(cmdline,sizeof(cmdline),0);
  169.       input(cmdline,sizeof(cmdline)-1);
  170.       stoupper(cmdline);
  171.       newline;
  172.  
  173.       {process stacked 'ns' at end of command line}
  174.       i := pos(' NS',cmdline);
  175.       if i = 0 then
  176.          i := pos(';NS',cmdline);
  177.  
  178.       if (i > 0) and (i = length(cmdline)-2) then
  179.       begin
  180.          cmdline[0] := chr(i-1);
  181.          linenum := -30000;    {go 30000 lines before stopping again}
  182.       end;
  183.    end;
  184.  
  185.  
  186.    (* ------------------------------------------------------------ *)
  187.    function scan_nextpar(var cmdline: string): string;
  188.       (* get the next space or ';' delimited part of a command line
  189.          and return it (removing the string from the command line) *)
  190.    var
  191.       i:      integer;
  192.       par:    string;
  193.  
  194.    begin
  195.       fillchar(par,sizeof(par),0);
  196.       while copy(cmdline,1,1) = ' ' do   {remove leading spaces}
  197.          delete(cmdline,1,1);
  198.  
  199.       (* find the end of the next word *)
  200.       i := 1;
  201.       while (i <= length(cmdline)) and (cmdline[i] <> ' ') and
  202.             (cmdline[i] <> ';') and (cmdline[i] <> ',') do
  203.          inc(i);
  204.  
  205.       (* copy the word to the next param and delete it from the command line *)
  206.       par := copy(cmdline,1,i-1);
  207.       delete(cmdline,1,i);
  208.  
  209.       scan_nextpar := par;
  210.    end;
  211.  
  212.  
  213.    (* ------------------------------------------------------------ *)
  214.    procedure get_nextpar;
  215.       (* get the next space or ';' delimited part of the command line
  216.          and move it to 'par' *)
  217.    begin
  218.       fillchar(par,sizeof(par),0);
  219.       par := scan_nextpar(cmdline);
  220.    end;
  221.  
  222.  
  223.    procedure check_carrier;
  224.    begin
  225.       if ((port[port_base+MSR] and MSR_RLSD)=0) and (not dump_user) then
  226.       begin
  227.          dump_user := true;
  228.          displn(^M^J'Carrier lost!'^M^J);
  229.       end;
  230.    end;
  231.  
  232.  
  233.    (* ------------------------------------------------------------ *)
  234.    procedure disp(msg:  string);
  235.    begin
  236.       write(msg);
  237.       if not local then
  238.       begin
  239.          INTR_transmit_data(msg);
  240.          check_carrier;
  241.       end;
  242.    end;
  243.  
  244.    (* ------------------------------------------------------------ *)
  245.    procedure newline;
  246.    var
  247.       c: char;
  248.  
  249.    begin
  250. {WRITE('`1');}
  251.       verify_txque_space;
  252. {WRITE('`2');}
  253.       disp(^M^J);
  254.       inc(linenum);
  255.  
  256.       if keypressed then
  257.       begin
  258.          c := readkey;
  259.          if (c = ^K) then
  260.          begin
  261.             disable_int;
  262.             control_k;
  263.             enable_int;
  264.          end
  265.          else
  266.  
  267.          if c <> carrier_lost then
  268.          begin
  269.             inc(pending_keys[0]);
  270.             pending_keys[length(pending_keys)] := c;
  271.          end;
  272.       end;
  273.    end;
  274.  
  275.    procedure displn(msg:  string);
  276.    begin
  277.       disp(msg);
  278.       newline;
  279.    end;
  280.  
  281.    procedure dispc(c: char);
  282.    begin
  283.       disp(c);
  284.    end;
  285.  
  286.    procedure space;
  287.    begin
  288.       dispc(' ');
  289.    end;
  290.  
  291.    (* ------------------------------------------------------------ *)
  292.    procedure spaces(n: integer);
  293.    begin
  294.       while n > 0 do
  295.       begin
  296.          space;
  297.          dec(n);
  298.       end;
  299.    end;
  300.  
  301.  
  302.    (* ------------------------------------------------------------ *)
  303.    procedure input(var line:  string;
  304.                    maxlen:    integer);
  305.    var
  306.       c:     char;
  307.  
  308.    begin
  309.       linenum := 1;
  310.       line := '';
  311.  
  312.       repeat
  313.          c := #0;
  314.  
  315.          while (c = #0) and (not dump_user) do
  316.          begin
  317.             check_time_left;
  318.  
  319.             if length(pending_keys) > 0 then
  320.             begin
  321.                c := pending_keys[1];
  322.                delete(pending_keys,1,1);
  323.             end;
  324.  
  325.             if keypressed then
  326.                c := readkey;
  327.  
  328.             if (not local) then
  329.             begin
  330.                check_carrier;
  331.                if INTR_receive_ready then
  332.                   c := INTR_receive_data;
  333.             end;
  334.  
  335.             if c = #0 then
  336.                give_up_time;
  337.          end;
  338.  
  339.          if dump_user then
  340.          begin
  341.             line := carrier_lost;
  342.             exit;
  343.          end;
  344.  
  345.          case c of
  346.             ' '..#126:
  347.                if maxlen = 0 then
  348.                begin
  349.                   line := c;
  350.                   dispc(c);
  351.                   c := ^M;    {automatic CR}
  352.                end
  353.                else
  354.  
  355.                if length(line) < maxlen then
  356.                begin
  357.                   if (wherex > 78) then
  358.                      newline;
  359.  
  360.                   line := line + c;
  361.                   dispc(c);
  362.                end;
  363.  
  364.             ^H,#127:
  365.                if length(line) > 0 then
  366.                begin
  367.                   dec(line[0]);
  368.                   disp(^H' '^H);
  369.                end;
  370.  
  371.             ^M:   ;
  372.  
  373.             ^B:   displn(wtoa(ofs(c))+'/'+ltoa(memavail));
  374.  
  375.             ^C:   dump_user := true;
  376.          end;
  377.  
  378.       until (c = ^M) or dump_user;
  379.  
  380.    end;
  381.  
  382.  
  383.    (* ------------------------------------------------------------ *)
  384.    procedure erase_prompt(len: integer);
  385.       {remove a prompt from display}
  386.    begin
  387.       dispc(^M);
  388.       spaces(len);
  389.       dispc(^M);
  390.       default_color;
  391.    end;
  392.  
  393.    (* ------------------------------------------------------------ *)
  394.    procedure get_cmdline_raw(len: integer);
  395.    begin
  396.       input(cmdline,len);
  397.       stoupper(cmdline);
  398.       erase_prompt(len+length(cmdline));
  399.    end;
  400.  
  401.    procedure prompt_def(what,options: string);
  402.    begin
  403.       disp(what+' '+options);
  404.    end;
  405.  
  406.    procedure get_def(what,options: string);
  407.    begin
  408.       prompt_def(what,options);
  409.       input(cmdline,sizeof(cmdline)-1);
  410.       stoupper(cmdline);
  411.       newline;
  412.    end;
  413.  
  414.    (* ------------------------------------------------------------ *)
  415.    procedure check_time_left;
  416.    var
  417.       time: integer;
  418.    begin
  419.       time := get_mins;
  420.       if ontime > time then
  421.          inc(time,1440);
  422.       tleft := tlimit+ontime-time;
  423.  
  424.       if tleft <= 0 then
  425.       begin
  426.          displn(^M^J'Time limit exceeded!'^M^J);
  427.          dump_user := true;
  428.       end;
  429.    end;
  430.  
  431.    procedure display_time;
  432.    begin
  433.       check_time_left;
  434.       disp('('+itoa(tleft)+' left) ');
  435.    end;
  436.  
  437.  
  438.    (* ------------------------------------------------------------------- *)
  439.    function nomore: boolean;
  440.       {check for more output to user; returns true if user doesn't want more}
  441.    begin
  442.       check_time_left;
  443.       if dump_user or (linenum >= 2000) then
  444.       begin
  445.          nomore := true;
  446.          exit;
  447.       end;
  448.  
  449.       nomore := false;
  450.       if linenum < user.pagelen then
  451.          exit;
  452.  
  453.       {preserve command-line context since the following code "pops up" over
  454.        what ever is running in the foreground}
  455.  
  456.       display_time(false);
  457.       prompt_def('More:','(Enter) or (Y)es, (N)o, (NS)non-stop? ');
  458.       get_cmdline_raw(56);
  459.       linenum := 1;
  460.  
  461.       get_nextpar;
  462.       if (par[1] = 'N') or dump_user then
  463.       begin
  464.          if par[2] = 'S' then
  465.             linenum := -30000     {go 30000 lines before stopping again}
  466.          else
  467.          begin
  468.             nomore := true;
  469.             linenum := 2000;   {flag that nomore is in effect}
  470.          end;
  471.       end;
  472.    end;
  473.  
  474.  
  475.    (* ------------------------------------------------------------ *)
  476.    procedure make_log_entry(s:string; f:boolean);
  477.    begin
  478.       if f then displn(s);
  479.    end;
  480.  
  481.    function verify_level(fun: char): boolean;
  482.    begin
  483.       verify_level := true;
  484.    end;
  485.  
  486.    procedure set_function(fun: char);
  487.    begin
  488.    end;
  489.  
  490.    procedure flag_files;
  491.    begin
  492.    end;
  493.  
  494.  
  495. begin
  496.    fillchar(rxque,sizeof(rxque),0);
  497.    fillchar(txque,sizeof(txque),0);
  498.    ontime := get_mins;
  499.    pending_keys := '';
  500. end.
  501.  
  502.